\ Definition of an array defining word Ham 12:00 11/01/92 \ This file contains version 6 (and supporting words) of FOR \ as developed in the file ARRAYS.SCR. Also included is SPILL \ to display the contents of an array. \ This file is suitable for use with INCLUDE. \ Bit tools Ham 12:00 11/01/92 CREATE BITS 1 C, 2 C, 4 C, 8 C, 16 C, 32 C, 64 C, 128 C, : S>B ( ? - f ) 0<> ; \ forces to a Boolean flag: -1 or 0 : AIM ( # adr - bit# adr' ) SWAP 8 /MOD ROT + ; : MASK ( bit# - bitmask ) BITS + C@ ; \ BITS contains eight bytes, each with a single bit turned \ on. These are used as masks with AND and OR to manipulate \ a particular bit. \ S>B (single to boolean) converts the bit to a flag (0 or -1). \ Bit tools Ham 12:00 11/01/92 : +BIT ( # adr - ) AIM SWAP MASK OVER C@ OR SWAP C! ; : -BIT ( # adr - ) AIM SWAP MASK NOT OVER C@ AND SWAP C! ; : @BIT ( # adr - f ) AIM C@ SWAP MASK AND S>B ; : ~BIT ( # adr - ) AIM 2DUP @BIT IF -BIT ELSE +BIT THEN ; \ +BIT turns bit on; -BIT turns bit off; @BIT fetches bit as \ a boolean flag; ~BIT (read "toggle bit") toggles the bit. : BITS>BYTES ( #bits - #bytes ) 8 /MOD SWAP IF 1+ THEN ; \ The above word determines the number of bytes needed for a \ bit array of a specified number of bits. \ Essential constants and arrays Ham 12:00 11/01/92 0 CONSTANT BITS WSIZE CONSTANT SINGLES 1 CONSTANT BYTES WSIZE 2* CONSTANT DOUBLES 1 CONSTANT PUT \ flags for the IF statement 0 CONSTANT GET \ in the DOES> part of FOR CREATE STORES ] C! ! 2! [ \ The offset into this array CREATE FETCHES ] C@ @ 2@ [ \ is given by OFFSET. : OFFSET ( type - offset ) DUP BYTES = IF DROP 0 THEN ; 1 1 2CONSTANT SET \ By placing two values on 0 1 2CONSTANT ZAP \ the stack, these words in -1 1 2CONSTANT FLIP \ effect include the PUT. \ Preliminary Ham 12:00 11/01/92 : >TYPE ( adr - adr' ; #slots-adr to type-adr ) WSIZE + ; \ FOR will create arrays that contain TWO pieces of \ information at the beginning: in addition to the type \ of array it is (bit, byte, single, or double) it will \ have a number that specifies the number of slots in the \ array. This number will then be used by a word that can \ take the name of an array and display its contents. \ FOR also will check the stack depth when the array is \ created and stop if the stack doesn't contain at least \ two items (number of slots and type of array). \ FOR itself Ham 12:00 11/01/92 : FOR CREATE ( #slots type - ) DEPTH 2 < ABORT" Specify no. of slots and size of slot." OVER , ( #slots ) DUP C, ( type ) ?DUP IF * ELSE BITS>BYTES THEN HERE SWAP DUP ALLOT ERASE DOES> ( datum 1 ndx <adr> -- | 0 ndx <adr> -- datum ) >TYPE COUNT ?DUP ( nonzero = numbers; 0 = bits ) IF DUP >R ( save size ) ROT * + R> OFFSET ROT IF STORES ELSE FETCHES THEN + PERFORM ELSE ( bits ) ROT ( flag: 1 = store, 0 = fetch ) IF ROT ?DUP ( nonzero means 1 bit or toggle ) IF 0< IF ~BIT ELSE +BIT THEN ELSE -BIT THEN ELSE @BIT THEN THEN ; \ Display word Ham 12:00 11/01/92 \ This screen and the following screens need be loaded only \ during development, when you will want to examine the \ contents of arrays. In the final version of the program \ you won't need the word SPILL, so these screens can be omitted : >DATA ( adr - adr' ; #slots-adr to data-adr ) >TYPE 1+ ; 27 CONSTANT ESC : NUF? ( - f ) ?TERMINAL DUP IF KEY 2DROP KEY ESC = THEN ; \ NUF? allows you to pause display of long arrays (any key) \ and then continue (any key) or quit (Esc key). \ Display word Ham 12:00 11/01/92 CREATE "TYPES ," bit byte single double" : .TYPE ( type - ) DUP BYTES > IF WSIZE / 2* THEN 6 * "TYPES + 6 -TRAILING TYPE ; : LARGE? ( type - f ) 3 > ; \ true = slot is 4 bytes or more : DOUBLE? ( type - f ) WSIZE > ; \ true = double-precision : }LINE ( type n - type ) OVER DOUBLE? IF DUP 5 ELSE DUP 10 THEN MOD IF DROP ELSE CR 4 .R ." | " THEN ; : VITALS ( array-adr - data-adr #slots type ) DUP >TYPE OVER >DATA ROT @ ( #slots ) ROT C@ ( type ) ; : TITLE ( #slots type - ) CR CR SWAP . .TYPE ." s:" ; \ Display word Ham 12:00 11/01/92 : DISPLAY ( adr -- ) VITALS 2DUP TITLE ?DUP IF ( numbers ) SWAP 0 DO I }LINE 2DUP I * + ( adr ) OVER DUP >R ( stash type ) OFFSET FETCHES + PERFORM R> ( retrieve it ) DUP LARGE? IF 12 ELSE 7 THEN SWAP DOUBLE? IF D.R ELSE .R THEN NUF? IF LEAVE THEN LOOP 2DROP ELSE ( bits ) 0 DO BITS I }LINE DROP I OVER @BIT 2 SPACES IF ASCII 1 ELSE ASCII - THEN EMIT NUF? IF LEAVE THEN LOOP DROP THEN CR ; : SPILL ( - ; name ) BL WORD FIND IF >BODY DISPLAY ELSE DROP CR ." No such array " THEN ;
